COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Auxilliary routines for Interpreter }
C00005 00003	(* aux routines: push, pop, upTrans, envLookup, getELev, getEntry, getVar, gtVarn, getNval *)
C00012 00004	(* aux routines: getPdb, freePdb, getEvent, freeEvent *)
C00016 00005	(* Aux routines to create & destroy variables: enterEntry, makeCmon, makeVar, killNode, killStack *)
C00024 00006	(* message passing routines: sendCmd, sendTrans *)
C00026 ENDMK
C⊗;
{$NOMAIN	Auxilliary routines for Interpreter }

%include ialhdr.pas;

{ Externally defined routines: }

	(* From ALLOC *)
procedure relVector(v: vectorp);				external;
function newTrans: transp;					external;
procedure relTrans(t: transp);					external;
function newNode: nodep;					external;
procedure relNode(n: nodep);					external;
function newEvent: eventp;					external;
procedure relEvent(n: eventp);					external;
function newEentry: enventryp;					external;
function newCmoncb: cmoncbp;					external;
function newFrame: framep;					external;
function newEheader: envheaderp; 				external;
procedure relPdb(n: pdbp);					external;
function newPdb: pdbp;						external;
function newEnvironment: environp;				external;

	(* From PP *)
procedure ppLine; 						external;
procedure ppOutNow; 						external;
procedure ppChar(ch: ascii); 					external;
procedure pp5(ch: c5str; length: integer); 			external;
procedure pp10(ch: cstring; length: integer); 			external;
procedure pp10L(ch: cstring; length: integer);			external;
procedure pp20(ch: c20str; length: integer); 			external;
procedure pp20L(ch: c20str; length: integer); 			external;
procedure ppInt(i: integer); 					external;
procedure ppReal(r: real); 					external;
procedure ppStrng(length: integer; s: strngp); 			external;

	(* From RSXMSG *)
function startArm: boolean;                                  	external;
procedure initMsg(var buf: messagep; var flag: boolean);     	external;
function SendArm: boolean;                                   	external;
function GetArm: boolean;                                    	external;
procedure signalArm;                                         	external;


procedure iAux1aGet; external;
procedure iAux1aGet; begin end;

(* aux routines: push, pop, upTrans, envLookup, getELev, getEntry, getVar, gtVarn, getNval *)

procedure push (n: nodep); external;	(* Also in iaux1b *)
procedure push ;
 begin				(* no need to check for overflow *)
 n↑.next := curInt↑.sp;
 curInt↑.sp := n;
 end;

function pop: nodep; external;	(* Also appears in IAUX2 and EAUX3B *) 
function pop;	
 begin
 pop := curInt↑.sp;
 if curInt↑.sp = nil then
   begin			(* **** error - stack underflow **** *)
   pp20L('Value Stack Underflo',20); ppChar('w'); ppLine;
   (* code to show where error occurred & to maybe recover??? *)
   end
  else curInt↑.sp := curInt↑.sp↑.next;
end;

procedure upTrans (var t: transp; tp: transp); external;
procedure upTrans ;
 begin
 if tp <> nil then tp↑.refcnt := tp↑.refcnt + 1; (* indicate new trans is in use *)
 if t <> nil then			(* check for old value *)
  begin
  t↑.refcnt := t↑.refcnt - 1;		(* we're done with trans now *)
  if t↑.refcnt <= 0 then relTrans(t);	(* release it if no one else wants it *)
  end;
 t := tp;				(* copy new trans pointer *)
 end;

function envLookup (offset: integer; envhdr: envheaderp): enventryp; external;
function envLookup ;
 var i,j,k: integer; env: environp;
 begin
 i := offset div 10;			(* which environment block *)
 j := offset mod 10;			(* entry in environment block *)
 if i < 5 then env := envhdr↑.env[i]	(* use direct look-up *)
   else begin				(* run through linked list *)
	env := envhdr↑.env[4];
	for k := 5 to i do env := env↑.next;
	end;
 envlookup := env↑.vals[j];
 end;

function getELev(hdr: envheaderp): integer; external;
function getELev;
 begin
 if hdr = sysEnv then getELev := 0
  else if hdr↑.procp then getELev := hdr↑.proc↑.level
  else getELev := hdr↑.block↑.level;
 end;

function getEntry (level, offset: byte): enventryp; external;
function getEntry ;
 var hdr: envheaderp;
 begin
 if level = 0 then hdr := sysEnv  (* level zero is predefined system variables *)
  else
   begin
   hdr := curInt↑.env;		(* look up the env entry given level-offset *)
   while level < getELev(hdr) do hdr := hdr↑.parent;	(* move up a level *)
   if level <> getELev(hdr) then	(* yow!!! no environment exists!!! *)
     begin
     pp20L('Attempt to access no',20); pp20('n-existent environme',20);
     pp20('nt - good luck!     ',16); ppLine;
     end;
   end;
 getEntry := envlookup(offset,hdr);
 end;

function getVar (level, offset: byte): enventryp; external;
function getVar ;
 var entry: enventryp; i, j: integer; p, b: nodep;
 begin
 entry := getEntry(level,offset);  (* get the environment entry *)
 while entry↑.etype = reftype do entry := entry↑.r;  (* resolve indirect refs *)
 if entry↑.etype = arraytype then	(* do array reference *)
   begin
   b := entry↑.bnds;
   j := 0;
   repeat
    p := pop;		(* get this subscript's value *)
    i := round(p↑.s);
    relNode(p);
    if i < b↑.lb then	(* subscript error *)
      begin
      pp20L('Subscript index less',20); pp20(' than lower bound:  ',19);
      ppInt(i); ppLine;
      i := b↑.lb
      end
     else if i > b↑.ub then	(* subscript error *)
      begin
      pp20L('Subscript index grea',20); pp20('ter than lower bound',20);
      pp5(':    ',2); ppInt(i); ppLine;
      i := b↑.ub
      end;
    j := j + b↑.mult * (i - b↑.lb);
    b := b↑.next;
   until b = nil;
   entry := envlookup(j,entry↑.a);	(* lookup the array entry *)
   end;
 getVar := entry;
 end;

function gtVarn (n: nodep): enventryp; external;
function gtVarn ;
 begin
 with n↑ do
  if ntype = leafnode then 
    with vari↑ do gtVarn := getVar(level,offset) (* access simple var *)
   else 
    with arg1↑.vari↑ do gtVarn := getVar(level,offset);  (* access array var *)
 end;

(* Also appears as a local procedure in IAUX1B *)
function getNval(n: nodep; var b: boolean): nodep; external;
function getNval;
 begin
 b := false;
 with n↑ do
  if (ntype <> leafnode) or (ltype = varitype) then
    begin n := pop; b := true end;
 if n <> nil then
   if n↑.ltype = pconstype then
     begin n := n↑.pcval; b := false end;
 getNval := n;
 end;

(* aux routines: getPdb, freePdb, getEvent, freeEvent *)

function getPdb: pdbp; external;
function getPdb;
 var p: pdbp;
 begin
 p := newPdb;
 with p↑ do
  begin				(* initialize it somewhat *)
  nextPdb := allPdbs;
  allPdbs := p;			(* add us to list of all processes *)
  next := nil;
  if curInt <> nil then
    begin
    env := curInt↑.env;
    level := getELev(env) + 1;
    priority := curInt↑.priority;
    cm := curInt↑.cm;
    end
   else
    begin
    env := sysEnv;
    level := 1;
    priority := 0;
    cm := nil;
    end;
  status := nullqueue;
  mode := 0;
  spc := nil;
  epc := nil;
  sp := nil;
  mech := nil;
  procp := false;
  evt := nil;
  end;
 getPdb := p;
 end;

procedure freePdb(p: pdbp); external;
procedure freePdb;
 var po: pdbp; b: boolean;
 begin					(* remove pdb from list *)
 if allPdbs = p then allPdbs := p↑.nextPdb
  else
   begin
   po := allPdbs;
   b := false;
   repeat				(* find pdb in list *)
    if po↑.nextPdb = p then b := true else po := po↑.nextPdb
   until b or (po = nil);
   if b then po↑.nextPdb := p↑.nextPdb;	(* splice us out of list *)
(* *** else complain??? *** *)
   end;
 relPdb(p);
 end;

function getEvent: eventp; external;
function getEvent;
 var e: eventp;
 begin
 e := newEvent;
 e↑.next := allEvents;		(* add to list of all events *)
 allEvents := e;
 e↑.count := 0;
 e↑.waitlist := nil;
 getEvent := e;
 end;

(* FreeEvent also appears in IAUX1B *)
procedure freeEvent(e: eventp); external;
procedure freeEvent;
 var eo: eventp; b: boolean;
 begin					(* remove event from list *)
 if allEvents = e then begin allEvents := e↑.next; b := true end
  else
   begin
   eo := allEvents;
   b := false;
   repeat				(* find event in list *)
    if eo↑.next = e then b := true else eo := eo↑.next
   until b or (eo = nil);
   if b then eo↑.next := e↑.next;	(* splice us out of list *)
   end;
 if b then relEvent(e);		(* if not in list already released *)
 end;

(* Aux routines to create & destroy variables: enterEntry, makeCmon, makeVar, killNode, killStack *)

function enterEntry (var i,j: integer; var env: environp;
		     envhdr: envheaderp; v: varidefp): enventryp; external;
function enterEntry;
 var e: enventryp; k: integer;
 begin
 if j = 9 then	  (* need to allocate new environment record *)
   begin
   env↑.next := newEnvironment;
   env := env↑.next;
   env↑.next := nil;
   for k := 0 to 9 do env↑.vals[k] := nil;
   j := 0;
   i := i + 1;
   if i < 5 then envhdr↑.env[i] := env;
   end
  else j := j + 1;
 k := 10 * i + j;
 if k > envhdr↑.varcnt then envhdr↑.varcnt := k;
 e := newEentry;	   (* get an environment entry for the variable *)
 env↑.vals[j] := e;
 e↑.etype := v↑.vtype;		(* copy datatype of variable *)
 if e↑.etype = rottype then e↑.etype := transtype; (* rots are transes internally *)
 enterEntry := e;
 end;

procedure makeCmon(e: enventryp; vari: varidefp); external;
procedure makeCmon;
 var c: cmoncbp;
 begin
 c := newCmoncb;
 with c↑ do
  begin
  cmon := vari↑.s;			(* point to cmon definition *)
  enabled := false;
  running := false;
  pdb := getPdb;			(* get us a pdb for later *)
  oldcmon := e↑.c;			(* remember if we're pushing anyone *)
  if c↑.cmon↑.oncond↑.ntype = forcenode then
    evt := getEvent			(* we'll need an event later *)
   else evt := nil;
  end;
 with c↑.pdb↑ do
  begin					(* set up pdb *)
  priority := (priority mod 10) + 1;	(* base level priority *)
  spc := c↑.cmon;
  sdef := spc;
  cm := c;				(* point to cmon def *)
  opdb := curInt;	(* pointer to parent pdb so we can get mech bits *)
  end;
 e↑.c := c;
 end;

procedure makeVar(e: enventryp; vari: varidefp; tbits: integer); external;
procedure makeVar;
 var i,j,k,size: integer; envhdr: envheaderp; env: environp; ep: enventryp;
     b,bo,bd: nodep;

 function getBound (n: nodep): integer;
  var e: enventryp;
  begin
  if n↑.ntype = exprnode then				(* value on stack *)
    begin n := pop; getBound := round(n↑.s) end
   else if n↑.ltype = svaltype then getBound := round(n↑.s) (* constant val *)
   else if n↑.ltype = pconstype then
    getBound := round(n↑.pcval↑.s)		(* predeclared constant *)
   else
    begin						(* variable value *)
    with n↑.vari↑ do e := getVar(level,offset);
    getBound := round(e↑.s);
    end;
  end;

 function getSize (b: nodep): integer;
  begin
  if b↑.next = nil then b↑.mult := 1
   else b↑.mult := getSize(b↑.next);
  getSize := b↑.mult * (b↑.ub - b↑.lb + 1);
  end;

 begin (* makeVar *)
 with e↑ do
  begin
  if tbits = 1 then etype := arraytype
   else if tbits = 2 then etype := proctype
   else if tbits >= 4 then etype := reftype;
  case etype of
svaltype:  s := 0.0;
vectype,
transtype: v := nil;
frametype: begin
	   f := newFrame;
	   f↑.vari := vari;
	   f↑.calcs := nil;
	   f↑.ftype := true;
	   f↑.valid := -1;
	   f↑.val := nil;
	   f↑.fdepr := nil;
	   f↑.dcntr := 0;
	   f↑.dev := nil;
	   end;
eventtype: evt := getEvent;
strngtype: begin length := 0; str := nil end;
cmontype:  begin
	   c := nil;
	   makeCmon(e,vari);
	   end;
proctype:  begin
	   etype := proctype;		(* fix up type field *)
	   p := vari↑.p;
	   penv := curInt↑.env;
	   end;
arraytype: begin
	   bd := vari↑.a↑.bounds;
	   bo := nil;
	   while bd <> nil do		(* bind the array bounds *)
	    begin
	    b := newNode;
	    if bo = nil then e↑.bnds := b else bo↑.next := b;
	    bo := b;
	    b↑.ntype := bndvalnode;
	    b↑.lb := getBound(bd↑.lower);
	    b↑.ub := getBound(bd↑.upper);
	    bd := bd↑.next
	    end;
	   size := getSize(e↑.bnds);
	   envhdr := newEheader;
	   envhdr↑.varcnt := 0;
	   e↑.a := envhdr;
	   env := newEnvironment;
	   env↑.next := nil;
	   envhdr↑.env[0] := env;
	   for j := 1 to 4 do envhdr↑.env[j] := nil;
	   for j := 0 to 9 do env↑.vals[j] := nil;
	   i := 0;
	   j := -1;
	   for k := 1 to size do
	    begin
	    ep := enterEntry(i,j,env,envhdr,vari);
	    makeVar(ep,vari,0);		(* make variable environment entry *)
	    end;
	   for i := j+1 to 9 do env↑.vals[i] := nil;
	   end;
otherwise {do nothing};
   end;
  end;
 end;

(* The following also appears as a local proc in IAUX1B two places! *)
procedure killNode(n: nodep); external;
procedure killNode;
 begin
 with n↑ do
  if ntype = leafnode then
    case ltype of
vectype:   if v↑.refcnt <= 0 then relVector(v);
transtype: if t↑.refcnt <= 0 then relTrans(t);
otherwise {do nothing};
    end;
 relNode(n);
 end;

procedure killStack; external;
procedure killStack;
 var n,np: nodep;
 begin
 n := curInt↑.sp;	(* top of stack *)
 while n <> nil do
  begin
  np := n↑.next;
  killNode(n);
  n := np;
  end;
 end;

(* message passing routines: sendCmd, sendTrans *)

procedure sendCmd; external;
procedure sendCmd;
 var b: boolean;
 begin
 b := sendArm;			(* send message to ARM *)
 with msg↑ do
  if not (cmd in [movesegcmd, movehdrcmd, setccmd,
		  armmagiccmd, realcmd, vectorcmd, transcmd]) then
    signalArm;				(* tell arm *)
 end;

procedure sendTrans(tr: transp); external;
procedure sendTrans;
 var i,j,k: integer; b: boolean;
 begin
 b := sendArm;			(* first send over message header *)
 with msg↑,tr↑ do
  begin
  for k := 0 to 1 do
   begin
   for i := 1 to 3 do
    for j := 1 to 2 do t[i + 3*(j-1)] := val[i,j + 2*k];
   b := sendArm;				(* send half over *)
   end;
  if refcnt <= 0 then relTrans(tr);
  end;
 end;